home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue25 / system / TFIND.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-08-06  |  7.3 KB  |  227 lines
  1. unit TFind;
  2.  
  3. interface
  4.  
  5. uses Wintypes, WinProcs, SysUtils, Classes, Controls, Forms, Dialogs, FileCtrl;
  6.  
  7. const
  8.     { Attribute bits }
  9.     TF_ReadOnly      =        $0001;       { Include read-only files     }
  10.     TF_Hidden     =        $0002;       { Include hidden files        }
  11.     TF_SysFile      =        $0004;       { Include system files        }
  12.     TF_AllAttribs =        $0007;       { mask for attributes         }
  13.  
  14.     { Drive Flags -  only apply if no drive letter given }
  15.     TF_DefDrive   =        $0008;       { search default drive        }
  16.     TF_Removable  =        $0010;       { search removable drives     }
  17.     TF_Fixed      =        $0020;       { search fixed drives         }
  18.     TF_Remote     =        $0040;       { search networked drives     }
  19.     TF_CDROM      =        $0080;       { search CDROM drives         }
  20.     TF_RamDisk    =        $0100;       { search RAM disks            }
  21.     TF_AllDrives  =        $01f8;       { mask for drive flags        }
  22.  
  23.     { Misc flags }
  24.     TF_ZIPOnly    =        $4000;       { ONLY look inside ZIP files  }
  25.     TF_ZIP        =        $8000;       { Include ZIP files in search }
  26.  
  27. type
  28.     TTreeFindProgress = procedure (Sender: TObject; const Dir: String) of object;
  29.  
  30.     TTreeFind = class (TObject)
  31.     private
  32.         flags: Word;
  33.         fSpec: String;
  34.         fFileSpec: String;
  35.         fList: TStringList;
  36.         fProgress: TTreeFindProgress;
  37.         function BuildDriveList (DriveList: TStringList): Boolean;
  38.         procedure TreeSearch (const Spec: String);
  39.         procedure SearchZipFile (const ZipFileName: String; const Spec: String);
  40.     public
  41.         constructor Create;
  42.         destructor Destroy; override;
  43.         property SearchFlags: Word read flags write flags;
  44.         property FileSpec: String read fFileSpec write fFileSpec;
  45.         property TheList: TStringList read fList;
  46.         property Progress: TTreeFindProgress read fProgress write fProgress;
  47.         procedure Execute;
  48.     end;
  49.  
  50. implementation
  51.  
  52. uses Match, Zip;
  53.  
  54. { TTreeFind }
  55.  
  56. constructor TTreeFind.Create;
  57. begin
  58.     flags := TF_DefDrive;
  59.     fSpec := '*.*';
  60.     fList := TStringList.Create;
  61. end;
  62.  
  63. destructor TTreeFind.Destroy;
  64. begin
  65.     fList.Free;
  66.     Inherited Destroy;
  67. end;
  68.  
  69. function TTreeFind.BuildDriveList (DriveList: TStringList): Boolean;
  70. var
  71.     Str: String;
  72.     DType, Idx: Integer;
  73.     DCB: TDriveComboBox;
  74. begin
  75.     Result := True;
  76.     { If no drive flags specified, time to bottle out }
  77.     if Flags and TF_AllDrives = 0 then begin
  78.         Result := False;
  79.         Exit;
  80.     end;
  81.  
  82.     { First, handle the simple TF_DefDrive case }
  83.     if Flags and TF_DefDrive = TF_DefDrive then begin
  84.         Flags := Flags and (not TF_DefDrive);
  85.         GetDir (0, Str);
  86.         DriveList.Add (UpperCase (Copy (Str, 1, 2)));
  87.     end;
  88.  
  89.     { If other drive flags also present ...}
  90.     if Flags <> 0 then begin
  91.         { Create a temporary errrr...hack...to enumerate the drives! }
  92.         DCB := TDriveComboBox.Create (Application.MainForm);
  93.         try
  94.             DCB.Parent := Application.MainForm;
  95.             DCB.Visible := False;
  96.             DCB.TextCase := tcUpperCase;
  97.  
  98.             { Loop through each drive in the list }
  99.             for Idx := 0 to DCB.Items.Count - 1 do begin
  100.                 Str := Copy (DCB.Items [Idx], 1, 2);
  101.                 DType := GetDriveType (PChar (Str + '\'));
  102.                 if (DType > Drive_No_Root_Dir) { Valid drive } and
  103.                    (Flags and (1 shl (DType + 2)) <> 0) then
  104.                        DriveList.Add (Str);
  105.             end;
  106.         finally
  107.             DCB.Free;
  108.         end;
  109.     end;
  110. end;
  111.  
  112. procedure TTreeFind.SearchZipFile (const ZipFileName: String; const Spec: String);
  113. var
  114.     idx: Integer;
  115.     zp: TZipFile;
  116.     fName: String;
  117. begin
  118.     zp := TZipFile.Create (ZipFileName);
  119.     try
  120.         for idx := 0 to zp.FilesCount - 1 do
  121.         begin
  122.             fName := ExtractFileName (zp.FileName [idx]);
  123.             if IsMatch (Copy (Spec, 3, 255), fName) then
  124.                 fList.Add (fName + #9 + ZipFileName);
  125.         end;
  126.     finally
  127.         zp.Free;
  128.     end;
  129. end;
  130.  
  131. procedure TTreeFind.TreeSearch (const Spec: String);
  132. var
  133.     Dir: String;
  134.     Err: Integer;
  135.     SearchRec: TSearchRec;
  136. begin
  137.     try
  138.         { Find first matching file }
  139.         Err := FindFirst ('*.*', Flags and TF_AllAttribs, SearchRec);
  140.         GetDir (0, Dir);
  141.         if Dir [Length (Dir)] <> '\' then Dir := Dir + '\';
  142.  
  143.         if Assigned (fProgress) and (Flags and TF_ZipOnly = 0) then fProgress (Self, Dir);
  144.  
  145.         { Loop for all files which match the specification }
  146.         while Err = 0 do begin
  147.             if Flags and TF_ZipOnly = 0 then
  148.                 if IsMatch (Copy (Spec, 3, 255), SearchRec.Name) then fList.Add (Dir + SearchRec.Name);
  149.  
  150.             { If it doesn't match the spec, it might still be a ZIP file ! }
  151.             if (Flags and (TF_ZIP or TF_ZIPOnly) <> 0) and IsMatch ('*.ZIP', SearchRec.Name) then
  152.             begin
  153.                 { Time to do some ZIP parsing ! }
  154.                 fProgress (Self, Dir + SearchRec.Name);
  155.                 SearchZipFile (Dir + SearchRec.Name, Spec);
  156.             end;
  157.  
  158.             Err := FindNext (SearchRec);
  159.         end;
  160.         FindClose (SearchRec);
  161.  
  162.         { Find first sub-directory (if any) }
  163.         Err := FindFirst ('*.*', (Flags and TF_AllAttribs) or faDirectory, SearchRec);
  164.  
  165.         { Loop for all sub-directories in this directory }
  166.         while Err = 0 do begin
  167.             if ((SearchRec.Attr and faDirectory = faDirectory) and (SearchRec.Name [1] <> '.')) then
  168.             begin
  169.                 ChDir (SearchRec.Name);
  170.                 TreeSearch (Spec);
  171.                 ChDir('..');
  172.             end;
  173.             Err := FindNext (SearchRec);
  174.         end;
  175.         FindClose (SearchRec);
  176.     except
  177.         { Should probably handle List-full errors here, but this }
  178.         { isn't likely to be an issue for 32-bit Delphi.         }
  179.     end;
  180. end;
  181.  
  182. procedure TTreeFind.Execute;
  183. var
  184.     Idx: Integer;
  185.     DirStash: String;
  186.     DriveList: TStringList;
  187. begin
  188.     fList.Clear;
  189.     { If no FSpec supplied, then use *.* }
  190.     fSpec := fFileSpec;
  191.     if fSpec = '' then fSpec := '*.*';
  192.  
  193.     DriveList := TStringList.Create;
  194.     try
  195.         DriveList.Sorted := True;
  196.         { If drive letter specified, only one drive to check }
  197.         if fSpec [2] = ':' then begin
  198.             DriveList.Add (UpperCase (Copy (fSpec, 1, 2)));
  199.             Delete (fSpec, 1, 2);
  200.         end
  201.         { Enumerate drives }
  202.         else if not BuildDriveList (DriveList) then Exit;
  203.  
  204.         Screen.Cursor := crHourglass;
  205.         try
  206.             { Now apply TreeSearch to each drive }
  207.             for Idx := 0 to DriveList.Count - 1 do
  208.             begin
  209.                 { Save current directory for the drive }
  210.                 GetDir (Ord (DriveList [Idx][1]) - $40, DirStash);
  211.                 { Start from root }
  212.                 ChDir (DriveList [Idx] + '\');
  213.                 { Do the search }
  214.                 TreeSearch (DriveList [Idx] + FSpec);
  215.                 { Restore stashed directory }
  216.                 ChDir (DirStash);
  217.             end;
  218.         finally
  219.              Screen.Cursor := crDefault;
  220.         end;
  221.     finally
  222.         DriveList.Free;
  223.     end;
  224. end;
  225.  
  226. end.
  227.